home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / w_classes.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  23.3 KB  |  522 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         w_classes.c
  5. * RCS:          $Header: w_classes.c,v 1.10 91/03/14 03:13:33 mayer Exp $
  6. * Description:  XLISP <--> Motif object and class interface.
  7. * Author:       Niels Mayer, HPLabs
  8. * Created:      Wed Jun 14 16:28:45 1989
  9. * Modified:     Thu Oct  3 20:28:22 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. **
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: w_classes.c,v 1.10 91/03/14 03:13:33 mayer Exp $";
  43.  
  44. /*
  45.  * <limits.h> defines machine dependent limits on sizes of numbers, if your
  46.  * machine doesn't have this, then your compiler doesn't conform to standards
  47.  * XPG2, XPG3, POSIX.1, FIPS 151-1 and you should complain to the manufacturer.
  48.  * 
  49.  * If for some reason your system isn't standards-conforming, you may work
  50.  * around this problem by using the following definitions (assuming 32 bit machine):
  51.  * 
  52.  * #define LONG_MIN (-2147483647 - 1)
  53.  */
  54. #include <limits.h>
  55.  
  56. #include <stdio.h>
  57. #include <Xm/Xm.h>
  58. #include "winterp.h"
  59. #include "user_prefs.h"
  60. #include "xlisp/xlisp.h"
  61.  
  62. #ifdef WINTERP_MOTIF_11
  63. /*
  64.  * For Motif 1.1, <X11/Intrinsic.h> included by <Xm/Xm.h> uses "fast subclassing"
  65.  * to implement XtIsShell(), therefore we don't need to declare shellWidgetClass.
  66.  */
  67. #else                /* MOTIF 1.0 */
  68.  extern WidgetClass shellWidgetClass; /* For Motif 1.0 this is needed by XtIsShell() macro from Intrinsics.h */
  69. #endif                /* WINTERP_MOTIF_11 */
  70.  
  71.  
  72. /******************************************************************************
  73.  * This is called from xldmem.c:sweep() when a WIDGETOBJ gets garbage collected.
  74.  * If the WIDGETOBJ gets gc'd, we must clear the backpointer to the WIDGETOBJ
  75.  * stored in XmNuserData resource of the widget -- after garbage collection, that
  76.  * pointer will be invalid.
  77.  *
  78.  * NOTE: this isn't really needed anymore now that every widget created
  79.  * in winterp is saved in v_savedobjs. These widgets will not be garbage
  80.  * collected until after they are destroyed, at which point get_widgetobj_widgetID()
  81.  * will return NIL and this proc won't do anything. Still, I'm leaving this around
  82.  * incase I decide to make saving every widget in v_savedobjs an optional feature.
  83.  * You want to save all widgets created if you're using the 'get_moused_widget'
  84.  * primitive alot to interactively build your intrface, or if your code violates
  85.  * my initial assumption that each callbackobj corresponds to a single widget.
  86.  * In the case of the rowcolumn widget's XmNentryCallback, that assumption
  87.  * doesn't hold, so I decided to save all active widgetobjs in v_savedobjs
  88.  * to avoid potential bugs resulting from garbage collection of widgets still
  89.  * referenced inside the toolkit.....
  90.  ******************************************************************************/
  91. void Wcls_Garbage_Collect_WIDGETOBJ(o_widget)
  92.      LVAL o_widget;        /* XLTYPE_WIDGETOBJ */
  93. {
  94.   Widget widget_id;
  95.   
  96.   if (widget_id = get_widgetobj_widgetID(o_widget)) { /* make sure widget hasn't been XtDestroyWidget()'d */
  97.     ARGLIST_RESET(); ARGLIST_ADD(XmNuserData, NULL);
  98.     XtSetValues(widget_id, ARGLIST());
  99.   }
  100. }
  101.  
  102.  
  103. /******************************************************************************
  104.  * Wcls_Widget_Destroy_Callback() -- 
  105.  * When a widget gets destroyed, we set the WIDGETOBJ's widgetID field to
  106.  * NIL to mark that the WIDGETOBJ's associated widget got destroyed. This
  107.  * ensures that operations on any WIDGETOBJ's that are sitting around
  108.  * (i.e. referenced in a user's variable) give an appropriate error.
  109.  * Widgets can be destroyed via XtDestroyWidget (== method :DESTROY on 
  110.  * WIDGET_CLASS). This callback will also get called on any child
  111.  * widget of a widget that got XtDestroyWidget()'d.
  112.  * 
  113.  * Additionally, destroying a widget will remove the associated WIDGETOBJ
  114.  * from v_savedobjs so that it may be garbage collected (if not referenced
  115.  * elsewhere). This in turn will allow the garbage collection of any
  116.  * PIXMAP_REFOBJ and CALLBACKOBJs that are referenced implicitly inside the
  117.  * Motif toolkit implementation of widgets.
  118.  ******************************************************************************/
  119. void Wcls_Widget_Destroy_CallbackProc(widgetID, client_data, call_data)
  120.      Widget    widgetID;
  121.      XtPointer client_data;    /* really an LVAL of type XLTYPE_WIDGETOBJ */
  122.      XtPointer call_data;
  123. {
  124.   LVAL o_widget;
  125.   o_widget = (LVAL) client_data;
  126.   set_widgetobj_widgetID(o_widget, NULL); /* mark widgetobject as invalid */
  127.  
  128.   /*
  129.    * remove from v_savedobjs all WIDGETOBJ, CALLBACKOBJ, or PIXMAP_REFOBJ
  130.    * corresponding to the destroyed widget ... this will allow them
  131.    * to be garbage collected next time gc() gets called.
  132.    */
  133.   {
  134.     extern LVAL v_savedobjs;
  135.     int  i = Wso_Hash(o_widget);
  136.     LVAL l_hbucket = getelement(v_savedobjs, i); /* a list of saved objects belonging to this hashbucket */
  137.     LVAL obj;
  138.     LVAL l_prev = NIL;
  139.     while (l_hbucket)         /* while there are elements in the hashbucket */
  140.       if ((obj = car(l_hbucket)) /* <obj> points to cur elt which is non-NIL */
  141.       && ((o_widget == obj)    /* is <obj> the WIDGETOBJ being destroyed? */
  142.           || ((ntype(obj) == XLTYPE_CALLBACKOBJ) /* or is <obj> a CALLBACKOBJ on this widget? */
  143.           && (get_callback_widget(obj) == o_widget))
  144.           || ((ntype(obj) == XLTYPE_PIXMAP_REFOBJ) /* or is <obj> a PIXMAPREFOBJ on this widget? */
  145.           && (get_pixref_widget(obj) == o_widget))
  146.           || ((ntype(obj) == XLTYPE_EVHANDLEROBJ) /* or is <obj> a EVHANDLEROBJ on this widget? */
  147.           && (get_evhandler_widget(obj) == o_widget))
  148.           )) {
  149.     l_hbucket = cdr(l_hbucket); /* l_hbucket now points to next elt or NIL */
  150.     if (!l_prev)
  151.       setelement(v_savedobjs, i, l_hbucket); /* remove first, head is now next elt */
  152.     else
  153.       rplacd(l_prev, l_hbucket); /* remove cur, point previous to next */
  154.       }
  155.       else {            /* go to next elt in hashbucket */
  156.     l_prev = l_hbucket;
  157.     l_hbucket = cdr(l_hbucket);
  158.       }
  159.   }
  160. }
  161.  
  162.  
  163. /******************************************************************************
  164.  * This procedure is meant to be called in an :ISNEW instance initializer
  165.  * method for any widget instances created as subclasses of WIDGET_OBJECT.
  166.  *
  167.  * This procedure initializes a WIDGETOBJ by initializing the WidgetID slot.
  168.  * It changes the node type generated by xlobj.c:clnew() from OBJECT to
  169.  * XLTYPE_WIDGETOBJ so that we can tell that this is a special kind of object.
  170.  * Finally, we save the  WIDGETOBJ in v_savedobjs[] so that the WIDGETOBJ
  171.  * doesn't get garbage collected. WIDGETOBJ's may be garbage collected after
  172.  * they are explicitly destroyed by the Xtoolkit, therefore we set up the
  173.  * XmNdestroyCallback to destroy WIDGETOBJ and any other lisp values
  174.  * (CALLBACKOBJs, PIXMAP_REFOBJs) implicitly referenced inside the
  175.  * Motif toolkit implementation of widgets.
  176.  ******************************************************************************/
  177. void Wcls_Initialize_WIDGETOBJ(o_widget, widget_id)
  178.      LVAL o_widget;        /* OBJECT/XLTYPE_WIDGETOBJ */
  179.      Widget widget_id;
  180. {
  181.   set_widgetobj_widgetID(o_widget, widget_id);
  182.   o_widget->n_type = XLTYPE_WIDGETOBJ; /* OBJECT o_widget is now really a WIDGETOBJ */
  183.   XtAddCallback(widget_id, XmNdestroyCallback, Wcls_Widget_Destroy_CallbackProc, (XtPointer) o_widget);
  184.  
  185.   /*
  186.    * Enter the WIDGETOBJ in v_savedobjs, so that it gets mark()'d.
  187.    * This way, it won't be garbage collected while the widget is 
  188.    * around. Wcls_Widget_Destroy_CallbackProc() above will remove
  189.    * the WIDGETOBJ when it's widget no  longer exists, thereby
  190.    * allowing it and any lisp objects it references to be garbage
  191.    * collected.
  192.    */
  193.   { 
  194.     int  i = Wso_Hash(o_widget);
  195.     LVAL l_hbucket;
  196.     extern LVAL v_savedobjs;
  197.     
  198.     xlsave1(l_hbucket);
  199.     l_hbucket = cons(o_widget, getelement(v_savedobjs, i));
  200.     setelement(v_savedobjs, i, l_hbucket);
  201.     xlpop();
  202.   }
  203. }
  204.  
  205.  
  206. /******************************************************************************
  207.  * Given a widget_id, this subroutine will return an XLISP widget-object
  208.  * instance. 
  209.  * This routine does the following:
  210.  *  0) Check to see if widget_id is a shell widget. If so, then we let wc_SHELL.c
  211.  *     lookup the shell widgetobj in it's hashtable. That's because XmNuserData
  212.  *     is not a valid resource for shell widgets. 
  213.  *  1) if the XmNuserData resource on the widget is non-NIL, we take the
  214.  *     value as the pointer to the widgetOBJ. (note that this resource
  215.  *     can be NIL (by default) for a widgetID that wasn't created via
  216.  *     winterp, or for a widgetOBJ that got garbage collected (see
  217.  *     Wcls_Garbage_Collect_WIDGETOBJ() above)
  218.  *  2) if XmNuserData resource is NIL, we must find the WINTERP widget-class
  219.  *     object associated with the widget and create a new instance of that
  220.  *     class around the widgetID, and return this widgetOBJ.
  221.  *     To do this, we call XtClass(widgetID) to get a pointer to the 
  222.  *     widget's class structure. During initialization of the WINTERP
  223.  *     widget-class objects, we have set up a table of associated widgetclassID's
  224.  *     WIDGETCLASSOBJ-ID's for use by Wcls_WidgetClassID_To_WIDGETCLASSOBJ().
  225.  *     From that fn's result, we get the WINTERP widget-class and create a
  226.  *     "wrapper" widget instance.
  227.  *  3) if the widget-class object is NIL or invalid, then we create a fake
  228.  *     generic widgetobj which is of class o_WIDGET_CLASS.
  229.  ******************************************************************************/
  230. LVAL Wcls_WidgetID_To_WIDGETOBJ(widget_id)
  231.      Widget widget_id;        /* assume that widget_id is a valid Widget, not NULL */
  232. {
  233.   extern LVAL Wcls_WidgetClassID_To_WIDGETCLASSOBJ(); /* def'd below */
  234.   extern LVAL Wshl_WidgetID_To_WIDGETOBJ(); /* from wc_SHELL.c */
  235.   extern LVAL o_WIDGET_CLASS;    /* from wc_WIDGET.c */
  236.   LVAL o_widget, o_widgetclass;
  237.   XtPointer user_data = (XtPointer) LONG_MIN; /* LONG_MIN from <limits.h> */
  238.  
  239.   if (!widget_id)
  240.     return (NIL);
  241.  
  242.   /* (0) check to see if the widget is a shell, if so, then look up widgetobj in table */
  243.   if (XtIsShell(widget_id)) {
  244.     return (Wshl_WidgetID_To_WIDGETOBJ(widget_id));
  245.   }
  246.  
  247.   /* (1) try to get valid widgetobj from XmNuserData backpointer. */
  248.   ARGLIST_RESET(); ARGLIST_ADD(XmNuserData, &user_data);
  249.   XtGetValues(widget_id, ARGLIST());
  250.   if (user_data == (XtPointer) LONG_MIN) /* make sure that XmNuserData resource actually exists on the widget in question. */
  251.     xlfail("Internal error in Wcls_WidgetID_To_WidgetObj() -- couldn't retrieve XmNuserData resource from widget. Motif bug?");
  252.   if ((o_widget = (LVAL) user_data) != NIL) {
  253.     if (ntype(o_widget) == XLTYPE_WIDGETOBJ) /* quick sanity check */
  254.       return (o_widget);
  255.     else
  256.       xlfail("Internal error in WidgetID_To_WidgetObj() -- someone's been messing with this widget's XmNuserData resource!");
  257.   }
  258.   /* Its not a shell, and XmNuserData wasn't set, so it must be a child of a Motif composite widget */
  259.   else if (o_widgetclass = Wcls_WidgetClassID_To_WIDGETCLASSOBJ(XtClass(widget_id))) /* returns NIL on failure */
  260.     /* (2): Create a new WIDGETOBJ of the appropriate class. */
  261.     o_widget = newobject(o_widgetclass, WIDGETOBJ_SIZE);
  262.   else {
  263.     /* (3) fail gracefully (i think). */
  264.     errputstr("Warning -- In Wcls_WidgetID_To_WIDGETOBJ() couldn't find a valid\n");
  265.     errputstr("           widgetclass object inside widget classrecord. Creating\n");
  266.     errputstr("           a \"generic\" WIDGETOBJ of class WIDGET_CLASS.\n");
  267.     o_widget = newobject(o_WIDGET_CLASS, WIDGETOBJ_SIZE);
  268.   }
  269.  
  270.   Wcls_Initialize_WIDGETOBJ(o_widget, widget_id);
  271.  
  272.   /* Store the pointer to the new widgetobj in the widget's XmNuserData resource. */
  273.   ARGLIST_RESET(); ARGLIST_ADD(XmNuserData, (XtArgVal) o_widget);
  274.   XtSetValues(widget_id, ARGLIST());  
  275.   return (o_widget);  
  276. }
  277.  
  278.  
  279. /******************************************************************************
  280.  * Fetches and removes a WIDGETOBJ from the argument stack, returning
  281.  * the widgetID. If the WIDGETOBJ has been destroyed or is not initialized,
  282.  * then this will signal an error. <wobj_return> is a pointer to an LVAL,
  283.  * it returns the WIDGETOBJ retrieved from the argument stack.
  284.  ******************************************************************************/
  285. Widget Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(wobj_return)
  286.      LVAL *wobj_return;
  287. {
  288.   Widget widget_id;
  289.  
  290.   if (widget_id = get_widgetobj_widgetID(*wobj_return = xlga_widgetobj()))
  291.     return (widget_id);
  292.   else
  293.     xlerror("Widget object has been :destroy'd or hasn't been initialized by :isnew.", *wobj_return);
  294. }
  295.  
  296.  
  297. /******************************************************************************/
  298. /******************************************************************************/
  299. /******************************************************************************/
  300. /******************************************************************************/
  301.  
  302. /* instance variable numbers for the class 'Class' --
  303.    from xlobj.c -- must update these if changed those! */
  304. #define MESSAGES    0    /* list of messages */
  305. #define IVARS        1    /* list of instance variable names */
  306. #define CVARS        2    /* list of class variable names */
  307. #define CVALS        3    /* list of class variable values */
  308. #define SUPERCLASS    4    /* pointer to the superclass */
  309. #define IVARCNT        5    /* number of class instance variables */
  310.  
  311. /* class variable numbers for classes derived from 'WIDGET_CLASS' */
  312. #define WIDGET_CLASS_ID        0 
  313. #define WIDGET_CLASS_SYM    1
  314. #define DERIVED_WIDGET_CLASS_CVALS_SIZE 2
  315.  
  316. /* 
  317.  * For looking up WIDGETCLASSOBJ<-->WidgetClass, we setup a table of
  318.  * these pairs, which is initialized by
  319.  * Wcls_Create_Subclass_Of_WIDGET_CLASS() and used by other proc's in this
  320.  * module.
  321.  */
  322. typedef struct _WidgetClass_Pair {
  323.   LVAL        widgetclass_OBJ;
  324.   WidgetClass widgetclass_ID;
  325. } WidgetClass_Pair;
  326.  
  327. #define WIDGETCLASS_TABLE_SIZE 50 /* need to increase this if we add more widgetclasses */
  328. static WidgetClass_Pair widgetclass_table[WIDGETCLASS_TABLE_SIZE];
  329. static int widgetclass_table_end_idx = 0; /* holds index of last element in widgetclass_table */
  330.  
  331. /*****************************************************************************
  332.  * This procedure creates a new 'Class' instance which inherits from the
  333.  * base class 'Widget_Class'. This derived class contains no new instance
  334.  * variables. This procedure is equivalent to doing:
  335.  * (set (implode <class_name>) 
  336.  *      (send Class :new
  337.  *                  '()                ;; no IVARS
  338.  *                  '(WIDGET_CLASS_ID  ;; class variable, inited to
  339.  *                                     ;; fixnum value <widgetclass_id>
  340.  *                    WIDGET_CLASS_SYM ;; class variable, inited to 
  341.  *                                     ;; implode(<class_name>)
  342.  *                  Widget_Class       ;; SUPERCLASS
  343.  ****************************************************************************/
  344. LVAL Wcls_Create_Subclass_Of_WIDGET_CLASS(class_name, widgetclass_id)
  345.      char* class_name;
  346.      WidgetClass widgetclass_id;
  347. {
  348.   extern LVAL o_WIDGET_CLASS;    /* from wc_WIDGET.c */
  349.   extern LVAL xlclass();    /* from xlobj.c */
  350.   LVAL self;
  351.   LVAL v_cvals;
  352.   LVAL l_cvars;
  353.  
  354.   /* create 'Class' instance;
  355.      set slot IVARTOTAL = WIDGETOBJ_SIZE (superclass has all slots)
  356.      set slot IVARS = NIL              ;; no IVAR slots in this class
  357.      set slot MESSAGES = NIL           ;; no messages (yet) for this class */
  358.   self = xlclass(class_name, WIDGETOBJ_SIZE); /* note: self won't get gc'd because it is a symbol's value */
  359.   
  360.   /* set slot IVARCNT = 0, since there's no I-Vars in this WIDGET_CLASS
  361.      subclass. Note that xlclass() above sets IVARTOTAL==WIDGETOBJ_SIZE==1
  362.      since WIDGET_CLASS contains a single slot that holds the WidgetID.
  363.      This is not accessible from lisp (since it's just a pointer), but
  364.      is accessible from C via the accessors get_widgetobj_widgetID()
  365.      and set_widgetobj_widgetID */
  366.   setivar(self, IVARCNT, cvfixnum((FIXTYPE)0));
  367.  
  368.   /* set SUPERCLASS slot to o_WIDGET_CLASS ... */
  369.   setivar(self, SUPERCLASS, o_WIDGET_CLASS);
  370.  
  371.   /* set CVARS  */
  372.   xlsave1(l_cvars);
  373.   l_cvars = cons(xlenter("WIDGET_CLASS_SYM"), NIL);
  374.   setivar(self, CVARS, cons(xlenter("WIDGET_CLASS_ID"), l_cvars));
  375.   xlpop(/*l_cvars*/);
  376.  
  377.   /* set CVALS -- set values for WIDGET_CLASS_ID and WIDGET_CLASS_SYM. */
  378.   v_cvals = newvector(DERIVED_WIDGET_CLASS_CVALS_SIZE);
  379.   setivar(self, CVALS, v_cvals); /* note: also prevents gc'ing of v_cvals since <self> is protected */
  380.   setelement(v_cvals, WIDGET_CLASS_ID, cvfixnum((FIXTYPE) widgetclass_id));
  381.   setelement(v_cvals, WIDGET_CLASS_SYM, xlenter(class_name));
  382.  
  383.   /* add <WidgetClass, WIDGETCLASSOBJ> pair to table for future lookups */
  384.   if (widgetclass_table_end_idx >= WIDGETCLASS_TABLE_SIZE)
  385.     xlfatal("Fatal Error in Initialization -- please recompile w_classes.c with a larger WIDGETCLASS_TABLE_SIZE.");
  386.   widgetclass_table[widgetclass_table_end_idx].widgetclass_OBJ = self;
  387.   widgetclass_table[widgetclass_table_end_idx].widgetclass_ID = widgetclass_id;
  388.   widgetclass_table_end_idx++;
  389.   
  390.   return (self);
  391. }
  392.  
  393.  
  394. /*****************************************************************************
  395.  * This routine gets called by xlprint() to print out an identifier for a
  396.  * WIDGETOBJ.
  397.  ****************************************************************************/
  398. Wcls_Print_WIDGETOBJ(fptr, o_widget)
  399.      LVAL fptr;            /* STREAM || USTREAM */
  400.      LVAL o_widget;        /* XLTYPE_WIDGETOBJ */
  401. {
  402.   extern LVAL o_WIDGET_CLASS;    /* from wc_WIDGET.c */
  403.   extern char temptext[];    /* global in winterp.c */
  404.   extern xlputstr();        /* xlprin.c */
  405.   char* classname;
  406.   LVAL v_cvals;
  407.   LVAL o_class = getclass(o_widget);
  408.   LVAL o_prevclass = NIL;
  409.   
  410.   /* loop through superclasses, stopping at WIDGET_CLASS or NIL(superclass of object) */
  411.   while ((o_class != o_WIDGET_CLASS) && (o_class)) {
  412.     o_prevclass = o_class;
  413.     o_class = getivar(o_class, SUPERCLASS);
  414.   }
  415.  
  416.   /*
  417.    * if the loop terminated with o_CLASS==o_WIDGET_CLASS and o_prevclass!=NIL
  418.    * then o_prevclass is the subclass of WIDGET_CLASS created by
  419.    * Wcls_Create_Subclass_Of_WIDGET_CLASS() in which the class variable
  420.    * WIDGET_CLASS_ID was set. So return that value as WidgetClassID, else NULL
  421.    */
  422.   if ((o_class == o_WIDGET_CLASS) && (o_prevclass) && (v_cvals = getivar(o_prevclass, CVALS)))
  423.     classname = (char *) getstring(getpname(getelement(v_cvals, WIDGET_CLASS_SYM)));
  424.   else
  425.     classname = "WIDGET_CLASS";
  426.   
  427.   sprintf(temptext, "#<Object(%s): #", classname);
  428.   xlputstr(fptr, temptext);
  429.   sprintf(temptext, AFMT, (long) o_widget);
  430.   xlputstr(fptr, temptext);
  431.   xlputc(fptr,'>');
  432. }
  433.  
  434.  
  435. /*****************************************************************************
  436.  * This routine accesses the WIDGET_CLASS_ID class variable that was
  437.  * initialized in the above Wcls_Create_Subclass_Of_WIDGET_CLASS(). This
  438.  * routine expects parameter o_class to be a class-object, that is
  439.  * xlobj.c:xlclass_p(o_class) must be true. If your code
  440.  * accidentally gives this routine an object instance rather than a class
  441.  * instance, then you're hosed as the while loop will go trapseing off
  442.  * through memory in a random fashion....
  443.  *
  444.  * This routine may be called with a class object as created by
  445.  * Wcls_Create_Subclass_Of_WIDGET_CLASS(), or it may be called with
  446.  * a class object that is a subclass of a class generated by
  447.  * Wcls_Create_Subclass_Of_WIDGET_CLASS(). In other words, it
  448.  * will work for widget subclasses created in lisp too.
  449.  *
  450.  * NOTE: the current implementation of this routine doesn't lookup
  451.  * info in widgetclass_table[] because it is faster to chain up a
  452.  * few superclasses to get to the WidgetClassID than to look for a
  453.  * matching widetclassID amongst the 40-odd widgetclasses in winterp.
  454.  ****************************************************************************/
  455. WidgetClass Wcls_WIDGETCLASSOBJ_To_WidgetClassID(o_class)
  456.      LVAL o_class;        /* OBJECT satisfying xlclass_p() */
  457. {
  458.   extern LVAL o_WIDGET_CLASS;    /* from wc_WIDGET.c */
  459.   LVAL v_cvals;
  460.   LVAL o_prevclass = NIL;
  461.   
  462.   /* loop through superclasses, stopping at WIDGET_CLASS or NIL(superclass of object) */
  463.   while ((o_class != o_WIDGET_CLASS) && (o_class)) {
  464.     o_prevclass = o_class;
  465.     o_class = getivar(o_class, SUPERCLASS);
  466.   }
  467.  
  468.   /*
  469.    * if the loop terminated with o_CLASS==o_WIDGET_CLASS and o_prevclass!=NIL
  470.    * then o_prevclass is the subclass of WIDGET_CLASS created by
  471.    * Wcls_Create_Subclass_Of_WIDGET_CLASS() in which the class variable
  472.    * WIDGET_CLASS_ID was set. So return that value as WidgetClassID, else NULL
  473.    */
  474.   if ((o_class == o_WIDGET_CLASS) && (o_prevclass) && (v_cvals = getivar(o_prevclass, CVALS)))
  475.     return ((WidgetClass) getfixnum(getelement(v_cvals, WIDGET_CLASS_ID)));
  476.   else
  477.     return ((WidgetClass) NULL);
  478. }
  479.  
  480. /******************************************************************************
  481.  * given a WidgetClass, this returns the WIDGETCLASSOBJ corresponding to that
  482.  * toolkit ID. If it can't find it, it returns NIL.
  483.  ******************************************************************************/
  484. LVAL Wcls_WidgetClassID_To_WIDGETCLASSOBJ(widget_class)
  485.      WidgetClass widget_class;    /* address of widget's class structure */
  486. {
  487.   register int idx;
  488.   
  489.   for (idx = 0 ; (idx < widgetclass_table_end_idx) ; idx++)
  490.     if (widgetclass_table[idx].widgetclass_ID == widget_class)
  491.       return (widgetclass_table[idx].widgetclass_OBJ);
  492.  
  493.   return (NIL);
  494. }
  495.  
  496.  
  497. /******************************************************************************
  498.  * (WIDGETOBJP <expr>)
  499.  * returns T if argument is a WIDGETOBJ, else NIL
  500.  ******************************************************************************/
  501. LVAL Wcls_Prim_WIDGETOBJP()
  502. {
  503.   extern LVAL true;
  504.   LVAL arg = xlgetarg();
  505.   xllastarg();
  506.   return (widgetobj_p(arg) ? true : NIL);
  507. }
  508.  
  509.  
  510. #ifdef DEBUG_WINTERP_1
  511. /******************************************************************************
  512.  * For debugging
  513.  ******************************************************************************/ 
  514. Wcls_Print_WidgetObj_Info(o_widget)
  515.      LVAL o_widget;        /* XLTYPE_WIDGETOBJ */
  516. {
  517.   fprintf(stderr, "Created <WIDGETOBJ:%lx>\n", o_widget);
  518.   fprintf(stderr, "    widgetID = %lx\n", get_widgetobj_widgetID(o_widget));
  519.   fprintf(stderr, "    windowID = %lx\n", XtWindow(get_widgetobj_widgetID(o_widget)));
  520. }
  521. #endif
  522.